home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / fileselect.tcl.z / fileselect.tcl
Text File  |  2002-07-08  |  17KB  |  614 lines
  1. #
  2. # fileselect.tcl --
  3. # simple file selector.
  4. #
  5. # Mario Jorge Silva                      msilva@cs.Berkeley.EDU
  6. # University of California Berkeley                 Ph:    +1(510)642-8248
  7. # Computer Science Division, 571 Evans Hall         Fax:   +1(510)642-5775
  8. # Berkeley CA 94720                                 
  9. # 
  10. #
  11. # Copyright 1993 Regents of the University of California
  12. # Permission to use, copy, modify, and distribute this
  13. # software and its documentation for any purpose and without
  14. # fee is hereby granted, provided that this copyright
  15. # notice appears in all copies.  The University of California
  16. # makes no representations about the suitability of this
  17. # software for any purpose.  It is provided "as is" without
  18. # express or implied warranty.
  19. #
  20.  
  21.  
  22. # names starting with "fileselect" are reserved by this module
  23. # no other names used.
  24. # Hack - FSBox is defined instead of fileselect for backwards compatibility
  25.  
  26.  
  27. # this is the proc that creates the file selector box
  28. # purpose - comment string
  29. # defaultName - initial value for name
  30. # cmd - command to eval upon OK
  31. # errorHandler - command to eval upon Cancel
  32. # If neither cmd or errorHandler are specified, the return value
  33. # of the FSBox procedure is the selected file name.
  34.  
  35. # Added preferences support
  36.  
  37. proc fileselect_Init {} {
  38.     global fileselect
  39.     if [info exists fileselect(init)] {
  40.     return
  41.     }
  42.     set fileselect(init) 1
  43.  
  44.     Preferences_Add "FS Box" \
  45. "The file select box lets you scan the directory structure.
  46. The FS box understands '~' and '~user' as shortcuts for your
  47. or the 'user's home directory.  Furthermore it tries to
  48. compelete a partial filename when you press the 'tab'." {
  49.     {fileselect(bigDirHas) fileselectBigDirHas {32} {Suppress startup listing longer than} 
  50. "FS box startup: Do not list a directory that has more than the here
  51. given number of entries.  If the directory has more entries you could
  52. press return to list them or enter a file/directory by hand."}
  53.     {fileselect(dotsByDefault) fileselectDotsByDefault OFF {List .* files by default}
  54. "Determines if dotfiles are listed by default. By default this is
  55. OFF.  The file select box has a checkbutton 'List all' that allows
  56. you to display the dotfiles if you want."}
  57.     {fileselect(home) fileselectHome {} {Default startup directory}
  58. "Defines which directory is listed on startup.  If empty the directory
  59. exmh was started is used."}
  60.     }
  61. }
  62.  
  63. proc FSBox {{purpose "Select file:"} {defaultName ""} {cmd ""} {errorHandler ""}} {
  64.     global fileselect
  65.     global exwin
  66.  
  67.     regsub -all " +" $defaultName _ defaultName
  68.  
  69.     set fileselect(origname) $defaultName
  70.     if $fileselect(dotsByDefault) {
  71.         set fileselect(pattern) "{*,.*}"
  72.        } else {
  73.         set fileselect(pattern) "*"
  74.     }
  75.     if ![info exists fileselect(lastDir)] {
  76.         if {$fileselect(home) == {}} {
  77.             set fileselect(lastDir) [pwd]
  78.         } else {
  79.             set fileselect(lastDir) $fileselect(home)
  80.         }
  81.     }
  82.  
  83.     set w .fileSelect
  84.     if [Exwin_Toplevel $w "Select File" FileSelect] {
  85.     # path independent names for the widgets
  86.     
  87.     set fileselect(list) $w.file.sframe.list
  88.     set fileselect(scroll) $w.file.sframe.scroll
  89.     set fileselect(direntry) $w.file.f1.direntry
  90.     set fileselect(entry) $w.file.f2.entry
  91.  
  92.     set fileselect(ok) $w.but.ok
  93.     set fileselect(cancel) $w.but.quit
  94.     set fileselect(msg) $w.label
  95.     
  96.     set fileselect(result) ""    ;# value to return if no callback procedures
  97.     
  98.     # widgets
  99.     Widget_Label $w label {top fillx pady 10 padx 20} -anchor w -width 24
  100.     Widget_Frame $w file Dialog {left expand fill} -bd 10
  101.     
  102.     Widget_Frame $w.file f1 Exmh {top fillx}
  103.     Widget_Label $w.file.f1 label {left} -text "Dir"
  104.     Widget_Entry $w.file.f1 direntry {right fillx expand}  -width 30
  105.     
  106.     Widget_Frame $w.file sframe
  107.     
  108.     scrollbar $w.file.sframe.yscroll -relief sunken \
  109.         -command [list $w.file.sframe.list yview]
  110.     FontWidget listbox $w.file.sframe.list -relief sunken \
  111.         -yscroll [list $w.file.sframe.yscroll set] -setgrid 1
  112.         if {$exwin(scrollbarSide) == "left"} {
  113.         pack append $w.file.sframe \
  114.             $w.file.sframe.yscroll {left filly} \
  115.             $w.file.sframe.list {right expand fill} 
  116.         } else {
  117.         pack append $w.file.sframe \
  118.             $w.file.sframe.yscroll {right filly} \
  119.             $w.file.sframe.list {left expand fill} 
  120.     }
  121.     Widget_Frame $w.file f2 Exmh {top fillx}
  122.     Widget_Label $w.file.f2 label {left} -text Name
  123.     Widget_Entry $w.file.f2 entry {right fillx expand}
  124.     
  125.     # buttons
  126.     $w.but.quit configure -text Cancel \
  127.         -command [list fileselect.cancel.cmd $w]
  128.     
  129.     Widget_AddBut $w.but ok OK \
  130.         [list fileselect.ok.cmd $w $cmd $errorHandler] {left padx 1 fill}
  131.     
  132.     Widget_AddBut $w.but list List \
  133.         [list fileselect.list.cmd $w] {left padx 1 fill}
  134.     Widget_CheckBut $w.but listall "List all" fileselect(pattern)
  135.     $w.but.listall configure -onvalue "{*,.*}" -offvalue "*" \
  136.         -command {fileselect.list.cmd $fileselect(direntry)}
  137.     $w.but.listall deselect
  138.     
  139.     # Set up bindings for the browser.
  140.     Widget_BindEntryCmd $fileselect(entry) <Return> \
  141.         "$fileselect(ok) invoke"
  142.     Widget_BindEntryCmd $fileselect(entry) <Control-c> \
  143.         "$fileselect(cancel) invoke"
  144.     Widget_BindEntryCmd $fileselect(direntry) <Return> \
  145.         "fileselect.list.cmd %W"
  146.     Widget_BindEntryCmd $fileselect(direntry) <space> \
  147.         "fileselect.tab.dircmd"
  148.     Widget_BindEntryCmd $fileselect(entry) <space> \
  149.         "fileselect.tab.filecmd"
  150.     Widget_BindEntryCmd $fileselect(direntry) <Tab> \
  151.         "fileselect.tab.dircmd"
  152.     Widget_BindEntryCmd $fileselect(entry) <Tab> \
  153.         "fileselect.tab.filecmd"
  154.     $fileselect(list) config -selectmode browse
  155.     
  156.     bind $fileselect(list) <Button-1> {
  157.         # puts stderr "button 1 release"
  158.         %W select set [%W nearest %y]
  159.         $fileselect(entry) delete 0 end
  160.         $fileselect(entry) insert 0 [%W get [%W nearest %y]]
  161.     }
  162.     
  163.     bind $fileselect(list) <Key> {
  164.         %W select set [%W nearest %y]
  165.         $fileselect(entry) delete 0 end
  166.         $fileselect(entry) insert 0 [%W get [%W nearest %y]]
  167.     }
  168.     
  169.     bind $fileselect(list) <Double-ButtonPress-1> {
  170.         # puts stderr "double button 1"
  171.         %W select set [%W nearest %y]
  172.         $fileselect(entry) delete 0 end
  173.         $fileselect(entry) insert 0 [%W get [%W nearest %y]]
  174.         $fileselect(ok) invoke
  175.     }
  176.     
  177.     bind $fileselect(list) <Return> {
  178.         %W select set [%W nearest %y]
  179.         $fileselect(entry) delete 0 end
  180.         $fileselect(entry) insert 0 [%W get [%W nearest %y]]
  181.         $fileselect(ok) invoke
  182.     }
  183.     }
  184.     set fileselect(text) $purpose
  185.     $fileselect(msg) configure -text $purpose
  186.     $fileselect(entry) delete 0 end
  187.     $fileselect(entry) insert 0 [file tail $defaultName]
  188.  
  189.     set dir [file dirname $defaultName]
  190.     if {"$dir" == "." && [info exists fileselect(lastDir)]} {
  191.         set dir $fileselect(lastDir)
  192.     }
  193.     if [catch {pwd} fileselect(pwd)] {
  194.         cd
  195.         set fileselect(pwd) [pwd]
  196.     }
  197.     fileselect.cd $dir
  198.     $fileselect(direntry) delete 0 end
  199.     $fileselect(direntry) insert 0 $dir/
  200.  
  201.     $fileselect(list) delete 0 end
  202.     $fileselect(list) insert 0 "Big directory:"
  203.     $fileselect(list) insert 1 $dir
  204.     $fileselect(list) insert 2 "Press Return for Listing"
  205.  
  206.     fileselect.list.cmd $fileselect(direntry) startup
  207.  
  208.     # set kbd focus to entry widget
  209.  
  210.     focus $fileselect(entry)
  211.  
  212.     # Wait for button hits if no callbacks are defined
  213.  
  214.     if {"$cmd" == "" && "$errorHandler" == ""} {
  215.         # wait for the box to be destroyed
  216.         tkwait variable fileselect(result)
  217.  
  218.         set path $fileselect(result)
  219.         set dir [file dirname $fileselect(result)]
  220.         if {$dir == "."} {
  221.             set dir [pwd]
  222.         }
  223.         set fileselect(lastDir) $dir
  224.         fileselect.cd $fileselect(pwd)
  225.         return [string trimright [string trim $path] /]
  226.     }
  227.     fileselect.cd $fileselect(pwd)
  228.     return ""
  229. }
  230.  
  231. proc fileselect.cd { dir } {
  232.     global fileselect
  233.     if [catch {cd $dir} err] {
  234.         fileselect.yck $dir
  235.         cd
  236.     }
  237. }
  238. # auxiliary button procedures
  239.  
  240. proc fileselect.yck { {tag {}} } {
  241.     global fileselect
  242.     $fileselect(msg) configure -text "Yck! $tag"
  243. }
  244. proc fileselect.ok {} {
  245.     global fileselect
  246.     $fileselect(msg) configure -text $fileselect(text)
  247. }
  248.  
  249. proc fileselect.cancel.cmd {w} {
  250.     global fileselect
  251.     set fileselect(result) {}
  252.     Exwin_Dismiss $w
  253. }
  254.  
  255. proc fileselect.list.cmd {w {state normal}} {
  256.     global fileselect
  257.     set seldir [$fileselect(direntry) get]
  258.     if {[catch {glob $seldir} dir]} {
  259.         fileselect.yck "glob failed"
  260.         return
  261.     }
  262.     if {[llength $dir] > 1} {
  263.         set dir [file dirname $seldir]
  264.         set pat [file tail $seldir]
  265.     } else {
  266.         set pat $fileselect(pattern)
  267.         set dir [lindex $dir 0]
  268.     }
  269.     fileselect.ok
  270.     update idletasks
  271.     if [file isdirectory $dir] {
  272.         fileselect.getfiles $dir $pat $state
  273.         focus $fileselect(entry)
  274.     } else {
  275.         fileselect.yck "not a dir"
  276.     }
  277. }
  278.  
  279. proc fileselect.ok.cmd {w cmd errorHandler} {
  280.     global fileselect
  281.     set selname [$fileselect(entry) get]
  282.     set seldir [$fileselect(direntry) get]
  283.  
  284.     if [string match /* $selname] {
  285.         set selected $selname
  286.     } else {
  287.         if [string match ~* $selname] {
  288.             set selected $selname
  289.         } else {
  290.             set selected [string trimright $seldir /]/$selname
  291.         }
  292.     }
  293.  
  294.     # some nasty file names may cause "file isdirectory" to return an error
  295.     if [catch {file isdirectory $selected} isdir] {
  296.         fileselect.yck "isdirectory failed"
  297.         return
  298.     }
  299.     if [catch {glob $selected} globlist] {
  300.         if ![file isdirectory [file dirname $selected]] {
  301.             fileselect.yck "bad pathname"
  302.             return
  303.         }
  304.         set globlist [list $selected]
  305.     }
  306.     fileselect.ok
  307.     update idletasks
  308.  
  309.     if {[llength $globlist] > 1} {
  310.         set dir [file dirname $selected]
  311.         set pat [file tail $selected]
  312.         fileselect.getfiles $dir $pat
  313.         return
  314.     } else {
  315.         set selected [lindex $globlist 0]
  316.     }
  317.     if [file isdirectory $selected] {
  318.         fileselect.getfiles $selected $fileselect(pattern)
  319.         $fileselect(entry) delete 0 end
  320.         $fileselect(entry) insert 0 $fileselect(origname)
  321.         return
  322.     }
  323.  
  324.     if {$cmd != {}} {
  325.         $cmd $selected
  326.     } else {
  327.         set fileselect(result) $selected
  328.     }
  329.     Exwin_Dismiss $w
  330. }
  331.  
  332. proc fileselect.getfiles { dir {pat *} {state normal} } {
  333.     global fileselect
  334.     $fileselect(msg) configure -text Listing...
  335.     update idletasks
  336.  
  337.     fileselect.cd $dir
  338.     if [catch {set files [lsort [glob -nocomplain $pat]]} err] {
  339.         $fileselect(msg) configure -text $err
  340.         $fileselect(list) delete 0 end
  341.         update idletasks
  342.         return
  343.     }
  344.     switch -- $state {
  345.     normal {
  346.         # Normal case - show current directory
  347.         $fileselect(direntry) delete 0 end
  348.         $fileselect(direntry) insert 0 [pwd]/
  349.     }
  350.     opt {
  351.         # Directory already OK (tab related)
  352.     }
  353.     newdir {
  354.         # Changing directory (tab related)
  355.         fileselect.cd $fileselect(lastDir)
  356.     }
  357.     startup {
  358.         # Avoid listing huge directories upon startup.
  359.         $fileselect(direntry) delete 0 end
  360.         $fileselect(direntry) insert 0 [pwd]/
  361.         if {[llength $files] > $fileselect(bigDirHas)} {
  362.         fileselect.ok
  363.         return
  364.         }
  365.     }
  366.     }
  367.  
  368.     # build a reordered list of the files: directories are displayed first
  369.     # and marked with a trailing "/"
  370.     if [string compare $dir /] {
  371.         fileselect.putfiles $files [expr {($pat == "*") ? 1 : 0}]
  372.     } else {
  373.         fileselect.putfiles $files
  374.     }
  375.     fileselect.ok
  376. }
  377.  
  378. proc fileselect.putfiles {files {dotdot 0} } {
  379.     global fileselect
  380.  
  381.     $fileselect(list) delete 0 end
  382.     if {$dotdot} {
  383.         $fileselect(list) insert end "../"
  384.         set dirnum 1
  385.     } else {
  386.         set dirnum 0
  387.     }
  388.     foreach i $files {
  389.     catch {
  390.         if {[file isdirectory $i]} {
  391.             if {"x$i" == "x."} continue
  392.             $fileselect(list) insert $dirnum $i/
  393.             incr dirnum
  394.         } else {
  395.             $fileselect(list) insert end $i
  396.         }
  397.     }
  398.     }
  399. }
  400.  
  401. proc FileExistsDialog { name } {
  402.     set w .fileExists
  403.     global fileExists
  404.     set fileExists(ok) 0
  405.     if [Exwin_Toplevel $w "File Exists"] {
  406.     message $w.msg -aspect 1000
  407.     pack $w.msg -side top -fill both -padx 20 -pady 20
  408.     $w.but.quit config -text Cancel -command {FileExistsCancel}
  409.     button $w.but.ok -text OK -command {FileExistsOK}
  410.     pack $w.but.ok -side left
  411.     bind $w.msg <Return> {FileExistsOK}
  412.     }
  413.     $w.msg config -text "Warning: file exists
  414. $name
  415. OK to overwrite it?"
  416.  
  417.     set fileExists(focus) [focus]
  418.     focus $w.msg
  419.     grab $w
  420.     tkwait variable fileExists(ok)
  421.     grab release $w
  422.     Exwin_Dismiss $w
  423.     return $fileExists(ok)
  424. }
  425. proc FileExistsCancel {} {
  426.     global fileExists
  427.     set fileExists(ok) 0
  428. }
  429. proc FileExistsOK {} {
  430.     global fileExists
  431.     set fileExists(ok) 1
  432. }
  433.  
  434. proc fileselect.getfiledir { dir {basedir [pwd]} } {
  435.     global fileselect
  436.  
  437.     set path [$fileselect(direntry) get]
  438.     set returnList {}
  439.  
  440.     if {$dir != 0} {
  441.     if {[string index $path 0] == "~"} {
  442.         set path $path/
  443.     }
  444.     } else {
  445.     set path [$fileselect(entry) get]
  446.     }
  447.     if [catch {set listFile [glob -nocomplain $path*]}] {
  448.     return  $returnList
  449.     }
  450.     set newdir "."
  451.     foreach el $listFile {
  452.     if {$dir != 0} {
  453.         if [file isdirectory $el] {
  454.         lappend returnList [file tail $el]
  455.         }
  456.     } elseif ![file isdirectory $el] {
  457.         lappend returnList [file tail $el]
  458.         set newdir [file dirname $el]
  459.     }        
  460.     }
  461.     if {[string compare $newdir "."] != 0} {
  462.     $fileselect(direntry) delete 0 end
  463.     $fileselect(direntry) insert 0 $newdir
  464.     }
  465.     
  466.     return $returnList
  467. }
  468.  
  469. proc fileselect.gethead { list } {
  470.     set returnHead ""
  471.  
  472.     for {set i 0} {[string length [lindex $list 0]] > $i}\
  473.     {incr i; set returnHead $returnHead$thisChar} {
  474.         set thisChar [string index [lindex $list 0] $i]
  475.         foreach el $list {
  476.         if {[string length $el] < $i} {
  477.             return $returnHead
  478.         }
  479.         if {$thisChar != [string index $el $i]} {
  480.             return $returnHead
  481.         }
  482.         }
  483.     }
  484.     return $returnHead
  485. }
  486.     
  487. proc fileselect.expand.tilde { } {
  488.     global fileselect
  489.  
  490.     set entry [$fileselect(direntry) get]
  491.     set dir [string range $entry 1 [string length $entry]]
  492.  
  493.     if {$dir == ""} {
  494.     return
  495.     }
  496.  
  497.     set listmatch {}
  498.  
  499.     ## look in /etc/passwd
  500.     if [file exists /etc/passwd] {
  501.     if [catch {set users [exec cat /etc/passwd | sed s/:.*//]} err] {
  502.         puts "Error\#1 $err"
  503.         return
  504.     }
  505.     set list [split $users "\n"]
  506.     }
  507.     if {[lsearch -exact $list "+"] != -1} {
  508.     if [catch {set users [exec ypcat passwd | sed s/:.*//]} err] {
  509.         puts "Error\#2 $err"
  510.         return
  511.     }
  512.     set list [concat $list [split $users "\n"]]
  513.     }
  514.     $fileselect(list) delete 0 end
  515.     foreach el $list {
  516.     if [string match $dir* $el] {
  517.         lappend listmatch $el
  518.         $fileselect(list) insert end $el
  519.     }
  520.     }
  521.     set addings [fileselect.gethead $listmatch]
  522.     if {$addings == ""} {
  523.     return
  524.     }
  525.     $fileselect(direntry) delete 0 end
  526.     if {[llength $listmatch] == 1} {
  527.     $fileselect(direntry) insert 0 [file dirname ~$addings/]
  528.     fileselect.getfiles [$fileselect(direntry) get]
  529.     } else {
  530.     $fileselect(direntry) insert 0 ~$addings
  531.     }
  532. }
  533.  
  534. proc fileselect.tab.dircmd { } {
  535.     global fileselect
  536.  
  537.     set dir [$fileselect(direntry) get]
  538.     if {$dir == ""} {
  539.     $fileselect(direntry) delete 0 end
  540.         $fileselect(direntry) insert 0 [pwd]
  541.     if [string compare [pwd] "/"] {
  542.         $fileselect(direntry) insert end /
  543.     }
  544.     return
  545.     }
  546.  
  547.     if [catch {set tmp [file isdirectory [file dirname $dir]]}] {
  548.     if {[string index $dir 0] == "~"} {
  549.         fileselect.expand.tilde
  550.     }
  551.     return
  552.     }
  553.     if {!$tmp} {
  554.     return
  555.     }
  556.     set dirFile [fileselect.getfiledir 1 $dir]
  557.     if ![llength $dirFile] {
  558.     return
  559.     }
  560.     if {[llength $dirFile] == 1} {
  561.     $fileselect(direntry) delete 0 end
  562.     $fileselect(direntry) insert 0 [file dirname $dir]
  563.     if [string compare [file dirname $dir] /] {
  564.         $fileselect(direntry) insert end /[lindex $dirFile 0]/
  565.     } else {
  566.         $fileselect(direntry) insert end [lindex $dirFile 0]/
  567.     }
  568.     fileselect.getfiles [$fileselect(direntry) get] \
  569.         "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
  570.     return
  571.     }
  572.     set headFile [fileselect.gethead $dirFile]
  573.     $fileselect(direntry) delete 0 end
  574.     $fileselect(direntry) insert 0 [file dirname $dir]
  575.     if [string compare [file dirname $dir] /] {
  576.     $fileselect(direntry) insert end /$headFile
  577.     } else {
  578.     $fileselect(direntry) insert end $headFile
  579.     }
  580.     if {$headFile == "" && [file isdirectory $dir]} {
  581.     fileselect.getfiles $dir\
  582.         "[file tail [$fileselect(direntry) get]]$fileselect(pattern)" opt
  583.     } else {
  584.     fileselect.getfiles [file dirname $dir]\
  585.         "[file tail [$fileselect(direntry) get]]*" newdir
  586.     }
  587. }
  588.  
  589. proc fileselect.tab.filecmd { } {
  590.     global fileselect
  591.  
  592.     set dir [$fileselect(direntry) get]
  593.     if {$dir == ""} {
  594.     set dir [pwd]
  595.     }
  596.     if {![file isdirectory $dir]} {
  597.     error "dir $dir doesn't exist"
  598.     }
  599.     set listFile [fileselect.getfiledir 0 $dir]
  600. #    puts $listFile
  601.     if ![llength $listFile] {
  602.     return
  603.     }
  604.     if {[llength $listFile] == 1} {
  605.     $fileselect(entry) delete 0 end
  606.     $fileselect(entry) insert 0 [lindex $listFile 0]
  607.     return
  608.     }
  609.     set headFile [fileselect.gethead $listFile]
  610.     $fileselect(entry) delete 0 end
  611.     $fileselect(entry) insert 0 $headFile
  612.     fileselect.getfiles $dir "[$fileselect(entry) get]$fileselect(pattern)" opt
  613. }
  614.